perm filename XREST.F4[NEW,LCS]4 blob
sn#162128 filedate 1975-06-06 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, BREP, EXCH, SORT2, NOZERO,
00200 C******* JDRAW,CENTR,LINX,UNPACK,ROFF,NOIR, KSIG, ALPHA, SPACER
00300 SUBROUTINE TAIL(RJX,RA,RMINI)
00400 COMMON /STF/RSTFAC(8),RSTJ2
00500 COMMON /PLTR/IPLT,RHT,DIS
00600 DIMENSION ITAIL(16)
00700 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00800 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00900 CALL CENTER(RJY)
01000 Q=-1.
01100 IF(RA)Q=1.
01200 IF(IPLT)GO TO 2
01300 ITAIL(1)=10
01400 1 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01500 RETURN
01600 2 P=Q
01700 IF(RMINI.NE.RSTJ2)P=P*.6
01800 ITAIL(1)=16
01900 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(P),P)
02000 C RA=-,STEM UP; RA=+, STEM DOWN.
02100 GO TO 1
02200 END
02300
02400 SUBROUTINE REST
02500 COMMON /STF/RSTFAC(8),RSTJ2/PLTR/IPLT,RHT,DIS
02600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
02700 EQUIVALENCE(J5,JQ(3)),(R3,RJQ(1)),(R4,RJQ(2)),(R7,RJQ(5))
02800 1,(R6,RJQ(4)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8))
02900 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
03000 DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
03100 1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
03200 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
03300 1 18, 20,10022,30023, 50023, 70022,110017,
03400 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03500 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03600 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03700 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03800
03900 L=J5
04000 IF(L.GT.1)L=1
04100 IF(L)L=-1
04200 C L>3 WHEN SEVERAL TAILS ON REST
04210 R10=RSTJ2
04250 IF(ABS(R4).LT.80)GO TO 2
04260 C NEXT FOR MINI-RESTS
04270 RSTJ2=RSTJ2*.7
04280 R2=R4-100
04290 IF(R4)R2=R4+100
04295 R4=R2+2.
04300 2 CALL CENTER(CENTR)
04400 IF(J5.EQ.-2)CENTR=CENTR+9.4*R10
04450 C CENTERS WHOLE REST
04500 CALL JDRAW(IRST(LRST(L+2)),R3,CENTR,RSTJ2,1.,1.)
04600 IF(IPLT.GE.0)GO TO 1
04700 IF(J5)GO TO 1
04800 L=L+1
04900 CALL FILLMS(MR(L),IRST(MF(L)),R3,CENTR,1.,1.)
05000 C WHY GO THROUGH NOTWRT??
05100 1 IF(R8.EQ.0)RETURN
05200 C TO PUT NUM OVER REST - MULTIPLE BARS.(R8=-1 =NO NUM. OVER WHOLE RST)
05300 R6=1.5
05400 C NUMBER SIZE
05500 R7=0
05600 C FOR BDR40 FONT
05700 R4=R4+10.6
05800 C HEIGHT ??
05810 IF(IPLT.GE.0)CALL LINX(R3-55.0,CENTR,R3+55.0+16.0*RSTJ2,CENTR)
05855 C HORIZ. LINE FOR CENTERING ON DPY ONLY. WILL NOT PRINT!
05900 C NEXT IS J3
06000 JQ(1)=R3+8.*RSTJ2
06100 R5=R8
06200 R8=0
06300 C ↑↑↑↑↑ ALL THIS BECAUSE OF PARAM NUMS IN MAKNUM AND NOTWRT
06400 IF(R5.GT.0)CALL MAKNUM(R5)
06500 J5=0
06600 R7=0
06700 END
06800
06900 C READS DATA
07000 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
07100 SUBROUTINE BREP(R3,RSTJ2)
07200 DIMENSION IREP(35)
07300 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
07400 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
07500 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
07600 1,100270022,280021,290021,300022,300023,290024,280024,270023
07700 1,270022, 300022, 270023, 290023/
07800 CALL CENTER(R)
07900 CALL JDRAW(IREP,R3,R,RSTJ2,1.,1.)
08000 END
08100
08200 SUBROUTINE FERMTA(RINV)
08300 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
08400 COMMON /PLTR/IPLT,RHT,DIS
08500 COMMON /STF/RSTFAC(8),RSTJ2
08600 DIMENSION JFERM(45)
08700 EQUIVALENCE (R3,RJQ(1))
08800 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
08900 1 190010,200003,170010,150012,120014,70014,30012,10010,
09000 1 10020003,100070007,80008,100008,110007,110006,100005,80005
09100 1 ,70006, 20,100081006, 80012, 90012, 91006, 110030002, 30008,
09200 1 70002,130008,170002, 200005, 200170002,141001,100005,130008,
09300 1 170002, 100070002, 41001, 5, 30008, 70002/
09400 IF(RINV.LT.17)GO TO 1
09500 JFERM(29)=16
09600 JFERM(35)=210005
09700 IF(RINV.NE.17)GO TO 2
09800 JFERM(29)=91006
09900 J=25
10000 GO TO 4
10100 2 JFERM(29)=16
10200 C FOR INVERTED MORDANT
10300 J=29
10400 4 RINV=1.
10500 GO TO 3
10600 1 J=1
10700 3 CALL JDRAW(JFERM(J),R3,CENTR,RSTJ2,1.,RINV)
10800 IF(IPLT.GE.0)RETURN
10900 IF(J.EQ.1)GO TO 5
11000 J=35
11100 JFERM(35)=10
11200 5 CALL FILLMS(JFERM(J),JFERM(J+1),R3,CENTR,1.,RINV)
11300 END
11400
11500 CC SUBROUTINE EXCH(X,Y)
11600 CC Z=X
11700 CC X=Y
11800 CC Y=Z
11900 CC END
12000 CF SUBROUTINE SORT2(RPOS,M)
12100 CF DIMENSION RPOS(2,200)
12200 CF L=2
12300 CF3 J=-1
12400 CF RX=RPOS(1,L-1)
12500 CF DO 2 K=L,M
12600 CF IF(RPOS(1,K).GE.RX)GO TO 2
12700 CF RX=RPOS(1,K)
12800 C WHY WERE ALL THE RX'S JX ????? 9/6/73
12900 CF J=K
13000 CF2 CONTINUE
13100 CF IF(J)GO TO 4
13200 CF K=L-1
13300 CF CALL EXCH(RPOS(1,K),RPOS(1,J))
13400 CF CALL EXCH(RPOS(2,K),RPOS(2,J))
13500 CF4 L=L+1
13600 CF IF(L.LE.M)GO TO 3
13700 CF END
13800
13900 CC SUBROUTINE NOZERO(X)
14000 CC IF(X.EQ.0)X=1
14100 CC END
14200
14300 SUBROUTINE PNUM
14400 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,RJQ(16),J3,J4,J5,J6,J7,
14500 1 J10J,IPUNC,DONT,RXX,RX,JQ(10) /STF/RSTFAC(-3/4),RSTJ2
14600 DIMENSION NUMQ(44),RNUMS(341)
14700 DATA
14800 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
14900 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
15000 1,250,256,261,266, 271,282,285,293,298,314,330,335/
15100 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
15200 1 104.015, 107.01,107.102, 104.107, 3.107,
15300 1 14.0, 1105.011, 101.015, 101.107, 22.0,
15400 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
15500 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
15600 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
15700 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
15800 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
15900 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
16000 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
16100 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
16200 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
16300 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
16400 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
16500 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
16600 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
16700 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
16800 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
16900 C THE NEXT IS FOR 'F' TO 'P'
17000 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
17100 DATA (RNUMS(K),K=132,199)/
17200 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
17300 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
17400 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
17500 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
17600 1 1103.107, 103.015, 1106.015, 0.015,
17700 1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015,
17800 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
17900 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
18000 1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
18100 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
18200 C 'Q' TO ')'
18300 DATA(RNUMS(K),K=200,341)/
18400 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
18500 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
18600 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
18700 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
18800 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
18900 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
19000 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
19100 1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
19200 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
19300 1 281.0, 1105.102, 105.105,103.105,104.102,104.105,105.102,103.102,
19400 1103.108, 106.112, 1106.112, 284., 1110.003, 2.003, 292., 1105.102,
19500 1 105.105,104.102,104.105,103.102,103.105,105.102,297.0,1110.007,
19600 1 2.007, 1110.0, 2.0, 313.0, 1101.015, 103.013, 105.010,
19700 1 106.006,106.002,105.102,103.105,101.107, 103.104,104.102,105.002
19800 1 ,105.006,104.01,103.012,101.015, 329.0,1107.015,105.013,
19900 1 103.01 ,102.006,102.002,103.102,105.105,107.107, 105.104,104.102
20000 1 ,103.002,103.006,104.01,105.012,107.015, 334.0,1110.003,
20100 1 2.003, 1104.009, 104.103, 341.0,1110.004, 2.004, 1101.009,
20200 1 107.101, 1101.101, 107.009/
20300 C 3RD ITEM IN 19400 NOT NEEDED 12/73
20400 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
20500
20600 CALL CENTX
20700 J10J=J5
20800 CALL NOZERO(R6)
20900 SIZ=R6*RSTJ2
21000 IPUNC=0
21100 IF(J10J.LT.44)GO TO 451
21200 IPUNC=J10J
21300 IF(J10J.EQ.44)J10J=38
21400 IF(J10J.GE.45)J10J=36
21500 IF(J5.NE.46)GO TO 451
21600 RXX=4
21700 CALL RJBX(-RXX)
21800 RX=16
21900 CENTR=CENTR+RX*SIZ
22000 451 IX=NUMQ(J10J+1)
22100 C IX=END # OF ITEM
22200 C IX+1=1ST PART OF ITEM
22300 CALL RDRAW(IX+1,RNUMS(IX),RNUMS,SIZ,R3,CENTR+RSTJ2*3.,SIZ)
22400 IF(IPUNC.EQ.0)RETURN
22500 IF(IPUNC.NE.46)GO TO 351
22600 CALL RJBX(SIZ*2.*RXX)
22700 C FOR "
22800 651 IPUNC=0
22900 GO TO 451
23000 351 RXX=11
23100 C FOR : AND ;
23200 CENTR=CENTR+RXX*SIZ
23300 J10J=38
23400 GO TO 651
23500 END
00100 C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00500 EQUIVALENCE(J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
00600 1(R8,RJQ(6)),(NRJ,RJQ(8)),(JX,JQ(11)),(RSX,JQ(12)),
00700 1(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
00800 1,(J6,JQ(4)),(R7,RJQ(5)),(R4,RJQ(2)),(IFNT,JQ(13)),
00900 1(NR,JQ(14)),(RSP,JQ(15)),(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
01000 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19)),(R9,RJQ(7))
01100 1,(JTR,RJQ(17)),(RF,RJQ(15)),(JJ2,RJQ(14)),(R3,RJQ(1))
01200 COMMON/STF/RSTFAC(8),RSTJ2
01300 DATA R4X/-2.1/,IFNT/1/, NR/'PRIM0'/
01400
01500 IF(JA.EQ.7)GO TO 20
01600 JTR=99
01700 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
01800 C ONLY 11 LETTERS WITHOUT FONT RESET.
01900 54 R=19.7*R5*RSTJ2
02000 RB=J3
02100 RW=R4
02200 J9=0
02300 C J9=0 AVOIDS ROTATION IN 'CLEFS'
02400 DO 50 KA=4,6
02410 NXZ=-1
02500 JY=RJQ(KA)*100.+.2
02600 JX=1000000
02700 DO 53 LA=1,4
02800 J5=JY/JX
02900 J5X=J5
03000 R3=J3
03100 IF(J5.EQ.99)GO TO 55
03110 73 IF(KFNT)IFNT=1
03115 C READS OLD SYS. AND NEW AUTOMATIC LWR CASE.
03120 IF(J5.LT.70)GO TO 72
03125 KFNT=-1
03127 C SETS AUTOMATIC LOWER CASE FLAG.
03130 IFNT=-1
03140 C 60 ADDED FOR LOWER CASE LETTERS.
03150 J5=J5-60
03200 C NO MORE IN THIS WD.
03300 72 IF(J5.LT.50)GO TO 1
03400 GO TO(2,3,9,4,5),J5-49
03500 C SWITCHES FOR DIFF. FONTS.(55 MAKES ')48=UPR,49=LWR,50=BDR,51=BDI,52=PRM
03550 C ********* UPPER AND LOWER NUMBERS(48,49) NO LONGER NEEDED.(SEE 73 ↑)
03560 IF(J5.GT.55)GO TO 10
03600 J5=36
03700 R4=R4+2.9
03800 C 55 WILL MAKE ' --- 56=? 57=! (THEY COME AFTER y z IN BDR46)
03900 GO TO 1
03910 10 J5=J5+6
03920 NRX=NR
03925 NXZ=0
03930 NR='BDR40'
03940 NJF=JFONT
03950 JFONT=-1
03960 GO TO 1
04000 2 NR='BDR40'
04100 C &=NON-ITALICS -- JFONT IS TEMPORARY SWITCH 5/74
04200 IF(JFONT)GO TO 9
04300 GO TO 11
04400 CC GO TO 8
04500 3 NR='BDI40'
04600 C @=51=ITALICS
04700 IF(JFONT)GO TO 9
04800 C TYPE '44 -1' TO MAKE ALL FONTS INTO 'PRIM'
04900 CC8 IF(IFNT.EQ.0)IFNT=-1
05000 GO TO 11
05100 4 FILL=-2
05200 GO TO 11
05300 5 FILL=0
05400 GO TO 11
05500 9 NR='PRIM0'
05600 GO TO 11
05700 1 CALL SPACER(J5,IFNT,RB,R)
05710 IF(J5.GT.60)GO TO 71
05720 C NOW 62=? 63=! IN BDR46
05800 IF(J5-47)7,6,11
05900 7 IF(JFONT.NE.0)GO TO 77
06000 IF(IPLT.GE.0)GO TO 30
06100 C JFONT=0 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
06200 CC J5=J6
06300 CC IF(IFNT.EQ.0)GO TO 30
06400 77 IF(J5.GE.36)GO TO 30
06500 C PUNCTUATION AND SPACE.
06600 IF(NR.NE.'PRIM0')GO TO 70
06700 IF(IFNT.EQ.1)GO TO 30
06800 IF(J5.LT.10)GO TO 30
06900 C JUMP TO USE UPPER CASE PRIM. LOWER CASE STARTS IN PRIM1.
07000 GO TO 71
07100 70 IF(J5.LE.9)GO TO 71
07200 IF(IFNT)J5=J5+26
07300 71 RX=R6
07400 R6=R5*.28
07500 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
07600 RY=R7
07700 R7=R6
07800 RZ=R8
07900 R4=R4+R4X
08000 C SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
08100 R8=FILL
08200 NRJ=NR
08300 C GETS RIGHT FILE
08400 JA=12
08450 C ANY NON-11 NUMBER .GT.10 WILL DO.
08500 CC R2=J2
08600 CALL CLEFS
08700 R6=RX
08800 R7=RY
08900 R8=RZ
09000 C PUTS BACK RIGHT STUFF
09100 IF(NXZ)GO TO 6
09110 NR=NRX
09120 JFONT=NJF
09130 GO TO 6
09200
09300 30 J7=0
09400 R6=R5
09500 CALL PNUM
09600 C 47=BLANK (WAS 99)
09700 6 J3=ROFF(RB)
09800 R4=RW
09900 11 JY=JY-J5X*JX
10000 C TO GET NEXT NUM OUT OF JY
10100 53 JX=JX/100
10200 50 CONTINUE
10300 55 IF(JTR.EQ.99)GO TO 100
10400 GO TO 52
10500
10600
10700 C FOR TRILLS
10800 C 7, POS1, STF, NT#, SIZE, POS2, X IF X=1 THEN NO WAVEY LINE
10900 20 CALL NOZERO(R5)
11000 R10=R5
11100 R5=.8*R5
11200 J3=J3+6*RSTJ2
11300 RF=R6
11400 JJ2=J3
11500 R6=518987.99
11600 C @tr LWR CASE, ITAL. TR
11700 R7=999999.99
11800 R8=R7
11900 JTR=J7
12000 GO TO 54
12100 52 IF(JTR.NE.0)GO TO 100
12200 C GO TO 100 IF NO WAVY LINE IS NEEDED
12300 R3=JJ2+20.*RSTJ2*R10
12400 JA=4
12500 J7=-2
12600 C J7 IS SWITCH TO DRAW WIGGLE
12700 R6=RF
12800 R9=.7*R10
12850 C SETS WIGGLE HEIGHT
12900 R8=.9*R10
13000 C R10 IS SIZE (P5)
13100 J10=0
13200 IF(IPLT)J10=1
13300 CALL ITMSUB
13400 C SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
13450 100 IF(KFNT)IFNT=1
13475 KFNT=0
13500 END
13600
13700
13800 SUBROUTINE SPACER(J5,IFNT,RB,R)
13900 C SPACES ALPHABET ITEMS.
14000 DATA RS/1.08/,RSPC/1./,RLWR/.96/
14100 C JUMP TO USE PRIMITIVE ALPHABET.
14200 IF(J5.GT.47)GO TO 10
14300 IF(J5.LE.9)GO TO 177
14400 IF(J5.LT.36)GO TO 10
14500 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
14600 177 RSX=RSPC
14700 IF(IFNT)RSX=.9
14800 GO TO 3
14900 10 IF(J5.LT.47)GO TO 5
15000 IF(J5.EQ.52)GO TO 14
15100 IF(J5.EQ.48)IFNT=1
15200 IF(J5.EQ.49)IFNT=-1
15210 C ABOVE 2 NO LONGER NEEDED.
15300 IF(J5.GE.55)GO TO 5
15400 C PUNCT. WILL EXPAND ABOVE 54.
15500 RETURN
15600 14 IFNT=0
15700 C #=52=PRIMITIVE
15800 JA=10
15900 RETURN
16000 5 RSX=RS
16100 IF(IFNT)RSX=RLWR
16200 C FOR LOWER CASE SPACING. (96%)
16300 IF(J5.EQ.22)GO TO 277
16400 IF(J5.NE.32)GO TO 3
16500 277 RSX=RSX*1.12
16600 C FOR M AND W
16700 3 IF(J5.GE.36)GO TO 21
16800 IF(J5.EQ.1)GO TO 21
16900 IF(J5.EQ.18)GO TO 21
17000 IF(J5.EQ.19)GO TO 21
17100 C FOR 1,I AND J
17200 IF(IFNT.GE.0)GO TO 4
17300 C NEXT FOR LOWER CASE ONLY.
17400 IF(J5.EQ.15)GO TO 21
17500 IF(J5.EQ.19)GO TO 21
17600 IF(J5.EQ.21)GO TO 21
17700 IF(J5.NE.29)GO TO 4
17800 21 IF(J5.NE.47)RSX=RSX*.68
17900 C FOR F,I,J,L,T
18000 4 RB=RB+R*RSX
18100 END
18200
18300
18400 CC SUBROUTINE JDRAW(M,R3,CENTR,RSTJ2,RX,RY)
18500 CC COMMON/LL/LL
18600 CC DIMENSION M(1)
18700 CC RC=RX*RSTJ2
18800 CC RD=RY*RSTJ2
18900 CC DO 2 K=2,M(1)
19000 CC CALL UNPACK(IA,IB,M(K))
19100 CC2 CALL LINES(FLOAT(IA)*RC+R3,FLOAT(IB)*RD+CENTR,LL)
19200 CC END
19300
19400 CC SUBROUTINE CENTER(CNTR)
19500 C TO CENTER ITEMS CREATED WITH DRAWING PROG.
19600 CC COMMON /STF/RSTFAC(8),RSTJ2
19700 CC COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
19800 CC COMMON/POSI/STF(8),JJ2,POS
19900 CC EQUIVALENCE (R4,RJQ(2))
20000 CC CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ2
20100 CC END
20200
20300 CC SUBROUTINE LINX(A,B,C,D)
20400 C SAVES SPACE FOR SINGLE LINES.
20500 CC CALL LINES(A,B,3)
20600 CC CALL LINES(C,D,2)
20700 CC END
20800
20900 CC SUBROUTINE UNPACK(M,N,I)
21000 CC COMMON/LL/L
21100 C L IS FOR VIS. OR INVIS. LINES.
21200 CC N=I
21300 CC L=2
21400 CC M=N/100000000
21500 CC IF(M.EQ.0)GO TO 2
21600 CC L=3
21700 CC N=N-100000000*M
21800 CC2 M=N/10000
21900 CC N=MOD(N,10000)
22000 CC IF(M.GT.1000)M=1000-M
22100 CC IF(N.GT.1000)N=1000-N
22200 CC END
22300
22400 CC FUNCTION ROFF(R)
22500 CC S=.5
22600 CC IF(R)S=-S
22700 CC ROFF=R+S
22800 CC RETURN
22900 CC END
23000
23100
23200 C************** NOIR, RJBX, CENTX ***************
23300 CF SUBROUTINE NOIR(RMINI)
23400 C BLACKS IN NOTES
23500 CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(12),B,C,KC,D,N,JY,M,L
23600 CF COMMON/PLTR/IPLT,RHT,DIS /XRN/IRN(4000)
23700 CF EQUIVALENCE (PRE,IRN(1))
23800 CF DATA BL/7.5/,BH/6.7/
23900 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
24000 CF IPOS=ROFF(RJQ(1)*DIS)
24100 CCCF IF(RMINI.LT..9)IPOS=IPOS+1
24200 CF JPOS=ROFF(CENTR*RHT)
24300 CF IF(-RMINI.EQ.PRE)GO TO 10
24400 CF PRE=-RMINI
24500 CCCF D=.25*RMINI
24600 CF D=.25
24700 CF B=BH*RMINI*RHT
24800 CF E=RMINI*DIS
24900 CF A=BL*E
25000 CF IC=A
25100 CF A=A*A
25200 CF E=-B/4.
25300 CF K=B
25400 CF B=B*B
25500 C USES EQUATION FOR ELLIPSE
25600 CF N=1
25700 CF NX=2
25800 CF6 DO 1 J=-K,K
25900 CF Y=J*J
26000 CF X=SQRT(A-(A*Y)/B)
26100 CF L=E-X
26200 CF M=X+E
26300 C THE TWO SIDES OF THE LINE
26400 CF IF(N)CALL EXCH(L,M)
26500 CF IRN(NX)=L
26600 CF IRN(NX+1)=M
26700 C C IS VERTICLE POS.
26800 CF NX=NX+2
26900 CF E=E+D
27000 C E IS TO TILT IT.
27100 CF1 N=-N
27200 CF10 CALL PLOT(IPOS+3,JPOS,3)
27300 CF N=2
27400 C 1ST LOC. OF ARRAY HAS "PRE"
27500 CF L=IPOS+IC
27600 CF DO 11 M=-K,K
27700 CF J=M+JPOS
27800 CF CALL PLOT(L+IRN(N),J,2)
27900 CF CALL PLOT(L+IRN(N+1),J,2)
28000 CF11 N=N+2
28100 CF END
28200
28300 CC SUBROUTINE RJBX(R)
28400 CC COMMON Q(4),R3,RJQ(39)/STF/RSTFAC(8),RSTJ2
28500 CC R3=R3+R*RSTJ2
28600 CC END
28700
28800 CC SUBROUTINE CENTX
28900 CC COMMON A,B,CENTR,D,E,R4,R(38) /STF/RSTFAC(8),RSTJ2
29000 CC 1 /POSI/STFF(8),JJ2,POS
29100 CC CENTR=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
29200 CC END
29300 C******** THE ABOVE ARE NOW IN SMALL.FAI (3/75)
29400
29500 C****** 7, STF, POS, HGT, NUM OF SHARPS OR FLATS(+ OR -), CLEF
29600 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
29700 SUBROUTINE KSIG
29800 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
29900 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(17),T,S,Z/STF/RSTFAC(-3/4),RSTJ2
30000 EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J6,JQ(4))
30100 1,(R6,RJQ(4))
30200
30300 JA=9
30400 C USES THIS KEY NUM IN NOTWRT
30500 C COUNTER
30600 IZ=IABS(J5)
30700 C NUMBER OF CALLS ON NOTWRT
30800 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
30900 JW=1
31000 R6=0
31100 IF(J5.GT.0)JW=2
31200 C THE CODE FOR FLAT OR SHARP
31250 IF(IZ.LT.100)GO TO 5333
31262 JW=3
31268 IZ=IZ-100
31275 C WILL MAKE NATURALS IF 100 IS ADDED OR SUBTRACTED.
31300 5333 CLEF=-(J6+1)
31400 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
31500 C CLEF NOW SET IN MAIN PROG.
31600 C IF NO CLEF GIVEN, TREBLE IS USED.
31700 T=10.
31800 IF(CLEF.LT.-2.)T=11.
31900 S=CLEF+4.
32000 IF(CLEF.EQ.-4)S=-1.
32100 IF(J5.LT.0)GO TO 253
32200 W=-3.
32300 YY=4.
32400 Z=11.
32500 C SHARPS
32600 GO TO 353
32700 253 W=3.
32800 YY=-4.
32900 Z=7.
33000 C FLATS
33100 353 N=1
33200 Z=Z+R4
33300 RX=JQ(1)
33400 RA=0
33500 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
33600 DO 553 KA=1,IZ
33700 J5=JW
33800 RJQ(1)=RX+RA
33900 RA=RA+13.*RSTJ2
34000 C MOVES OVER FOR NEXT ACCI.
34100 RD=Z
34200 R4=Z
34300 IF(CLEF.NE.-1.)GO TO 7
34400 IF(R4.GT.12.)R4=R4-7.
34500 GO TO 9
34600 7 R4=R4-S
34700 IF(R4.GT.T)R4=R4-7.
34800 C ABOVE ARRANGES VERT. POS OF ACCIS.
34900 9 J4=R4
35000 C FOR VERT. POS. IN 'DRWNT' (WHEN PLOTTING.)
35100 CALL CENTX
35200 CALL NOTWRT
35300 Z=RD+W
35400 IF(N)Z=RD+YY
35500 553 N=-N
35600 END